Amiga Collections: New Zealand Amiga Users Group/New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).zip/New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).adf/BASIC/ObEdhi

AmigaBASIC Source Code | 1993-12-02 | 12KB | 579 lines

'     Last modified : Oct 23, 1985

  DEFINT a-z

'   Format of the file produced by this program
'
'   long ColorSetOffset
'   long DataSetOffset
'   long depth                  number of bit planes
'   long width                  width of object in pixels
'   long height                 height of object in pixels
'   short flags:
'     fVsprite=1                TRUE if its a vsprite, FALSE if its a BOB
      collisionPlaneIncluded=2  'never set by this editor
      imageShadowIncluded=4     'never set by this editor
      SAVEBACK=8                'save background before drawing BOB
      OVERLAY=16                'color 0 for BOB is transparent, not black
      SAVEBOB=32                'let BOB act like a paint brush
'   short planePick          which playfield planes do object planes map to
'   short planeOnOff         set to 0 by object editor
'   <first bit-plane>
'   <second bit-plane>       /* must begin on even byte boundary */
'     :
'   <last bit-plane>
'   <imageShadow bit-plane>  not currently produced by object editor
'   <collision bit-plane>    not currently produced by object editor
'

  DEF FNArraySize& = 3+INT((Bobright+16)/16)*(bobbottom+1)*Depth
  DIM DrawRect(3),ToolName$(6)

  scrn=-1 'puts window in workbench screen
  Depth=2
  WinY=185: WinX=617
'If BOBs are to be created with other than 2 bit-planes
' alter next 3 lines (only if machine has more than 256k)
  INPUT "Screen depth (1-4)";Depth
  scrn=1
  SCREEN scrn,640,200,Depth,2
  WINDOW 2,"GT's Object Editor",(0,0)-(WinX,WinY),31,scrn

  PRINT "GT's Amiga-BASIC Object Editor"
  LIBRARY "graphics.library"
  GOSUB InitConstant
  GOSUB InitFile
  GOSUB InitMenu
StartOver:
  ON MENU GOSUB CheckMenu : MENU ON
  ON MOUSE GOSUB CheckMouse : MOUSE ON
  ON BREAK GOSUB IgnoreBreak: BREAK ON
  DrawBoundary
  GOSUB PrintStatus
  Unfinished = -1
  WHILE Unfinished
    SLEEP 'this program is completely event driven
  WEND
  MENU RESET
  CLS
  END

InitConstant:
  IF FRE(-1)>50000 THEN MaxTool=6 :ELSE MaxTool=5
  ToolMode=1
  currentcolor=1
  MaxY=120: MaxX=500
  MaxY10=MaxY+10: MaxX10=MaxX+10
  statusline=22
  Top = 20: Left = 450
  MaxBobRight=3*0.8*FRE(0)/4 : MaxBobBottom=0.8*FRE(0)/4
  RETURN

InitFile:
  CLS
  IF Depth = 2 THEN
    PRINT "Enter 1 if you want to edit sprites"
    INPUT "Enter 0 if you want to edit bobs > ",fVsprite
  ELSE
    fVsprite = 0 'user can't edit sprite
  END IF
  bobbottom=31
  IF fVsprite =0 THEN INPUT "Enter bob size: X,Y ",Bobright,bobbottom
  CLS
  FileName$=""
  Flags=SAVEBACK+OVERLAY+fVsprite
  IF fVsprite = 0 THEN Bobright=Bobright-1:bobbottom=bobbottom-1 :ELSE Bobright=15
  currentX=Bobright:currentY=bobbottom
  maxcolor=2^Depth - 1
  DIM rgb%(maxcolor,3)
  PlanePick=maxcolor
  Change=0
  RETURN

InitMenu:
  MENU 1,0,1,"File"
  MENU 1,1,1,"New"
  MENU 1,2,1,"Open ..."
  MENU 1,3,1,"Save"
  MENU 1,5,1,"Quit"
  MENU 1,4,1,"Save as ..."
  MENU 2,0,1,"Tools"
  MENU 3,0,1,"Enlarge"
  MENU 3,1,1,"4x4"
  MENU 3,2,1,"1x1"
  MENU 4,0,1,""
  ToolName$(1)="Pen"
  ToolName$(2)="Line"
  ToolName$(3)="Oval"
  ToolName$(4)="Rectangle"
  ToolName$(5)="Eraser"
  ToolName$(6)="Paint"
  FOR i=1 TO MaxTool
    MENU 2,i,1,ToolName$(i)
  NEXT i

  RETURN

CheckMenu:
  MenuId=MENU(0)
  MenuItem=MENU(1)
  ON MenuId GOTO FileMenu,ToolsMenu,FatBits

CheckMouse:
  GetCurrentXY
  IF currentY>MaxY+10 AND currentX>400 THEN EditColor
  IF currentY>MaxY+10 THEN CheckColor
  IF NOT fEnlarge THEN
    IF currentY>bobbottom+10 OR currentX>Bobright+10 THEN RETURN
    IF currentY>=bobbottom AND currentX>=Bobright THEN ChangeSizePicture
    IF (currentY>bobbottom OR currentX>Bobright) THEN RETURN
  ELSE
    IF currentX>Bobright*Offset OR currentY>bobbottom*Offset THEN RETURN
  END IF
  StartY=currentY
  StartX=currentX
  Change=-1
  ON ToolMode GOSUB Pen,DrawLine,DrawCircle,DrawRectangle,ErasePicture,PaintPicture
  RETURN

DrawLine:
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF InsideBob THEN
      InvertVideo
      LINE (StartX,StartY)-(currentX,currentY) 'draw line
      LINE (StartX,StartY)-(currentX,currentY) 'erase line
      NormalVideo
    END IF
  WEND
  LINE (StartX,StartY)-(currentX,currentY),currentcolor
  RETURN

FatBits:
  ON MenuItem GOTO Enlarge, Shrink

Enlarge:
  IF fEnlarge THEN RETURN
  fBig = -1
  IF bobbottom > 31 THEN
    LOCATE 17,1:PRINT "Y >= 31 too large to enlarge. ";
  ELSEIF Bobright >=100 THEN
    LOCATE 17,1:PRINT "X >=100 too large to enlarge. ";
  ELSE
    fBig = 0
  END IF
  IF fBig THEN
    PRINT "Press any key to continue";
10 a$=INKEY$:IF a$="" GOTO 10
    LOCATE 17,1:PRINT "                                  ";
    PRINT "                            ";
    RETURN
  END IF
  Offset = 4:OffsetB=Offset-1
  ChangeToolsMode 0 'Disable Tools
  MenuItem = 1
  GOSUB ToolsMenu
  fEnlarge = -1 'Enlarge flag

  DIM BobArray(FNArraySize&)
  GET (0,0)-(Bobright,bobbottom),BobArray
  LINE (Left-1,Top-1)-(Left+Bobright+1,Top+bobbottom+1),,b
  PUT (Left,Top),BobArray
  ERASE BobArray

  LINE (0,0)-(Bobright*2,bobbottom*2),0,bf
  LINE (-1,-1)-((Bobright+1)*Offset,(bobbottom+1)*Offset),,b
  m=0:n=0
  FOR i=Left TO Left+Bobright
    n=0
    FOR j=Top TO Top+bobbottom
      x=POINT(i,j)
      IF x>0 THEN LINE (m,n)-(m+OffsetB,n+OffsetB),x,bf
      n=n+Offset
    NEXT j
    m=m+Offset
  NEXT i
  RETURN


Shrink:
  IF fEnlarge = 0 THEN RETURN
  ChangeToolsMode 1
  fEnlarge = 0
  DIM BobArray(FNArraySize&)
  GET (Left,Top)-(Left+Bobright,Top+bobbottom),BobArray
  LINE (Left-1,Top-1)-(Left+Bobright+1,Top+bobbottom+1),0,bf
  LINE (0,0)-(Bobright*Offset+Offset,Offset*bobbottom+Offset),0,bf
  DrawBoundary
  PUT (0,0),BobArray
  ERASE BobArray
  RETURN


SUB ChangeToolsMode (Mode) STATIC
SHARED MaxTool
  FOR i=2 TO MaxTool
    MENU 2,i,Mode
  NEXT
END SUB

Pen:
  IF fEnlarge THEN GOTO BigPen
  GetCurrentXY
  IF InsideBob THEN PSET (currentX,currentY),currentcolor
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF NOT InsideBob THEN RETURN
    LINE -(currentX,currentY),currentcolor
  WEND
  RETURN

BigPen:
  GOSUB GetX1Y1
  IF InsideBob THEN
    PSET (currentX+Left,currentY+Top),currentcolor
    LINE (x1,y1)-(x1+OffsetB,y1+OffsetB),currentcolor,bf
  END IF
  WHILE MOUSE(0)<>0
    GOSUB GetX1Y1
    IF InsideBob  THEN
      PSET (currentX+Left,currentY+Top),currentcolor
      LINE (x1,y1)-(x1+OffsetB,y1+OffsetB),currentcolor,bf
    END IF
  WEND
  RETURN

GetX1Y1:
  GetCurrentXY
  IF (currentX>=0 AND currentX < (Bobright+1)*Offset) AND (currentY>=0 AND currentY <(bobbottom+1)*Offset) THEN
    InsideBob = -1
    currentX = INT(currentX/Offset)
    x1=currentX*Offset
    currentY=INT(currentY/Offset)
    y1=currentY*Offset
  ELSE
    InsideBob = 0
  END IF
  RETURN

DrawCircle:
  GOSUB TrackRect
  CenterX=(DrawRect(1)+DrawRect(3))/2
  CenterY=(DrawRect(2)+DrawRect(0))/2
  RadiusX=(DrawRect(3)-DrawRect(1))/2
  RadiusY=(DrawRect(2)-DrawRect(0))/2
  IF RadiusX=0 OR RadiusY=0 THEN RETURN
  Aspect!=ABS(RadiusY/RadiusX)
  IF RadiusX < RadiusY THEN RadiusX=RadiusY
  CIRCLE (CenterX,CenterY),RadiusX,currentcolor,,,Aspect!
  RETURN

DrawRectangle:
  GOSUB TrackRect
  LINE (DrawRect(1),DrawRect(0))-(DrawRect(3),DrawRect(2)),currentcolor,b
  RETURN

ErasePicture:
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF currentX-5<0 OR currentY-3<0 THEN InsideBob=0
    IF InsideBob THEN
      LINE (currentX-5,currentY-3)-(currentX,currentY),1,bf
      LINE (currentX-5,currentY-3)-(currentX,currentY),0,bf
    END IF
  WEND
  DrawBoundary
  RETURN

PaintPicture:
  IF InsideBob THEN
     LINE(0,bobbottom+1)-(Bobright+1,bobbottom+1),currentcolor
     LINE(Bobright+1,0)-(Bobright+1,bobbottom+1),currentcolor
     PAINT (currentX, currentY),currentcolor
     DrawBoundary
  END IF
  RETURN

TrackRect:
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF InsideBob THEN
      DrawRect(0)=StartY
      DrawRect(1)=StartX
      DrawRect(2)=currentY
      DrawRect(3)=currentX
      InvertVideo
      FrameRect DrawRect() 'Draw it
      FrameRect DrawRect() 'Erase it
      NormalVideo
    END IF
  WEND
  IF currentY<StartY THEN DrawRect(0)=currentY: DrawRect(2)=StartY
  IF currentX<StartX THEN DrawRect(1)=currentX: DrawRect(3)=StartX
  RETURN

ChangeSizePicture:
  MaxMem = 0.8 * FRE(0)
  COLOR 0
  DrawBoundary
  COLOR 1
  InvertVideo
  WHILE MOUSE(0)<>0
    GetCurrentXY
    IF (currentY < MaxY) AND (currentY > 0) THEN
     IF (currentX <= MaxX) AND (currentX >= 10) THEN
      IF MaxMem > (Depth * currentX * currentY /8) THEN
        IF fVsprite = 1 THEN Bobright = 15:currentX=15::ELSE Bobright=currentX
        bobbottom=currentY
        DrawBoundary
        DrawBoundary
      END IF
     END IF
    END IF
  WEND
  NormalVideo
  GOSUB GetPicture
  GOSUB RedrawPicture
  RETURN

ToolsMenu:
  ToolMode=MenuItem
  GOSUB PrintToolStatus
  RETURN

FileMenu:
  ON MenuItem GOSUB NewFile,OpenFile,SaveFile,SaveFileAs,Quit
  RETURN

NewFile:
  GOSUB CheckSave
  IF CancelCommand THEN RETURN
  CLS
  GOSUB InitFile
  GOTO StartOver

OpenFile:
  GOSUB CheckSave
  IF CancelCommand THEN RETURN
  CLS
  INPUT "Enter Filename > ",FileName$
  IF FileName$="" THEN NewFile
  OPEN FileName$ FOR INPUT AS 1
  ColorSet=CVL(INPUT$(4,1))
  DataSet=CVL(INPUT$(4,1))
  Depth=CVL(INPUT$(4,1))
  Bobright=CVL(INPUT$(4,1)) - 1
  bobbottom=CVL(INPUT$(4,1)) - 1
  REM --- UNDONE if ColorSet<>0 or DataSet<>0, read image.editor format file
  Flags=CVI(INPUT$(2,1))
  IF Flags AND 1 THEN fVsprite = 1 :ELSE fVsprite = 0
  IF PlanePick <> CVI(INPUT$(2,1)) THEN
    PRINT "Error: file not compatible with this SCREEN"
  ELSE
    PlaneOnOff=CVI(INPUT$(2,1))
    ArraySize&=FNArraySize&
    DIM BobArray(ArraySize&)
    BobArray(0)=Bobright + 1
    BobArray(1)=bobbottom + 1
    BobArray(2)=Depth
    FOR i=3 TO ArraySize&-1
      BobArray(i)=CVI(INPUT$(2,1))
    NEXT i
    CLS
    currentX=Bobright: currentY=bobbottom
    GOSUB RedrawPicture
  END IF
  CLOSE #1
  Change=0
  GOTO StartOver

SaveFileAs:
  FileName$=""
SaveFile:
  IF fEnlarge THEN GOSUB Shrink
  GOSUB GetPicture
  IF FileName$="" THEN CLS: INPUT "Enter Filename > ",FileName$
  IF FileName$<>"" THEN
    OPEN FileName$ FOR OUTPUT AS 1
    PRINT #1, MKL$(0); 'ColorSet
    PRINT #1, MKL$(0); 'DataSet
    PRINT #1, MKI$(0);MKI$(BobArray(2)); 'depth
    PRINT #1, MKI$(0);MKI$(BobArray(0)); 'width
    PRINT #1, MKI$(0);MKI$(BobArray(1)); 'height
    PRINT #1, MKI$(Flags);
    PRINT #1, MKI$(PlanePick);  'planePick
    PRINT #1, MKI$(0);  'planeOnOff
    FOR i=3 TO ArraySize&-1
      PRINT #1, MKI$(BobArray(i));
    NEXT i
    IF fVsprite THEN
    'Output the colors for sprite> Change output values for different colors
      PRINT #1,MKI$(&Hff); 'White. Color 1
      PRINT #1,MKI$(0); 'Black. Color 2
      PRINT #1,MKI$(&Hf80); 'Orange. Color 3
    END IF
    CLOSE#1
  END IF
  GOSUB RedrawPicture
  Change=0
  RETURN

Quit:
  Cancel=0
  GOSUB CheckSave
  IF CancelCommand THEN RETURN
  Unfinished=0
  RETURN

GetPicture:
  ArraySize&=FNArraySize&
  DIM BobArray(ArraySize&)
  GET (0,0)-(Bobright,bobbottom),BobArray
  RETURN

RedrawPicture:
  CLS
  PUT (0,0),BobArray,PSET
  ERASE BobArray
  DrawBoundary
  GOSUB PrintStatus
  RETURN

PrintStatus:
  PrintCurrentXY
  GOSUB PrintToolStatus
  GOSUB PrintColorBar
  GOSUB PrintEditBox
  RETURN

PrintToolStatus:
  LOCATE statusline,24: PRINT SPACE$(10);
  LOCATE statusline,24: PRINT ToolName$(ToolMode);
  RETURN

PrintColorBar:
  COLOR 0
  LOCATE 19,1: PRINT " ";
  colorbar = WINDOW(5)-10
  LINE(10,colorbar)-(60,colorbar+20),currentcolor,bf
  COLOR 1
  x=70
  FOR i=0 TO maxcolor
    LINE (x,colorbar)-(x+20,y+colorbar+20),i,bf
    LINE (x,colorbar)-(x+20,y+colorbar+20),1,b
    x=x+20
  NEXT i
  LINE (70,colorbar+22)-(90+maxcolor*20,colorbar+26),0,bf
  x=70+currentcolor*20:LINE ( x,colorbar+22)-(x+20,colorbar+26),1,bf
  RETURN

CheckColor:
  IF currentY<colorbar OR currentY>colorbar+20 THEN RETURN
  IF currentX<70 THEN RETURN
  i=INT((currentX-70)/20)
  IF i>maxcolor THEN RETURN
  currentcolor=i
  LINE(456,colorbar+1)-(584,colorbar+30),0,bf
  LOCATE 19,58+rgb%(i,1):PRINT  "R";
  LOCATE 20,58+rgb%(i,2):PRINT "G";
  LOCATE 21,58+rgb%(i,3):PRINT "B";
  LOCATE statusline+1,1:PRINT  SPACE$(60);
  GOSUB PrintColorBar
  RETURN

EditColor:
  IF currentY<colorbar OR currentX<455 THEN RETURN
  i=(currentY-colorbar-1)\10 : j=(currentX-455)\8
  IF i>2 OR j>15 THEN RETURN
  cuc=currentcolor
  LOCATE 19+i,58 :PRINT SPACE$(16);:LOCATE 19+i,58+j
  IF i=0 THEN PRINT  "R"; :ELSE IF i=1 THEN PRINT "G"; :ELSE PRINT  "B";
  rgb%(cuc,i+1)=j:PALETTE cuc,rgb%(cuc,1)/15,rgb%(cuc,2)/15,rgb%(cuc,3)/15
  LOCATE statusline+1,1
  PRINT  "RED: ";rgb%(cuc,1);INT(rgb%(cuc,1)*6.666)/100;"  GREEN: ";rgb%(cuc,2);INT(rgb%(cuc,2)*6.666)/100;"   BLUE: ";rgb%(cuc,3);INT(rgb%(cuc,3)*6.666)/100;"         ";
  RETURN


PrintEditBox:
  LINE(455,colorbar)-(585,colorbar+31),1,b
  red=rgb%(currentcolor,1):green=rgb%(currentcolor,2):blue=rgb%(currentcolor,3)
  COLOR 1
  LOCATE 19,58+red:PRINT "R";
  LOCATE 20,58+green:PRINT  "G";
  LOCATE 21,58+blue:PRINT  "B";
  RETURN

CheckSave:
  IF fEnlarge THEN GOSUB Shrink
  CancelCommand=0
  IF Change THEN
    BEEP
    GOSUB GetPicture
    CLS
    PRINT "Current file is not saved."
    PRINT "Do you want to save it?"
    PRINT " Press Y key if you want to save it"
    PRINT " Press N key if don't you want to save it"
    PRINT " Press C key if you want to cancel command"
    Response=0
    WHILE Response=0
      a$=INKEY$
      IF a$<>"" THEN
        a$=UCASE$(a$)
        IF a$="Y" THEN Response=1
        IF a$="N" THEN Response=2
        IF a$="C" THEN Response=3
        IF Response=0 THEN BEEP
      END IF
    WEND
    GOSUB RedrawPicture
    IF Response=1 THEN GOSUB SaveFileAs
    IF Response=3 THEN CancelCommand=-1
  END IF
  RETURN

SUB GetCurrentXY STATIC
  SHARED currentX,currentY,InsideBob,Bobright,bobbottom
  dummy=MOUSE(0)
  currentX=MOUSE(1)
  currentY=MOUSE(2)
  InsideBob=-1
  IF currentX>Bobright OR currentY>bobbottom THEN InsideBob=0
  IF currentX<0 OR currentY<0 THEN InsideBob=0
  END SUB

SUB PrintCurrentXY STATIC
  SHARED statusline,currentX,currentY
  LOCATE statusline,1: PRINT "Bob size X:";currentX;
  LOCATE statusline,17: PRINT "Y:";currentY;
END SUB

SUB DrawBoundary STATIC
SHARED Bobright,bobbottom
  x=Bobright+10
  y=bobbottom+10
  LINE (0,y)-(x,y)
  LINE (x,y)-(x,0)
  LINE (0,bobbottom+1)-(x,bobbottom+1)
  LINE (Bobright+1,y)-(Bobright+1,0)
END SUB

SUB InvertVideo STATIC
   CALL SetDrMd& (WINDOW(8),3)
END SUB

SUB NormalVideo STATIC
   CALL SetDrMd& (WINDOW(8),1)
END SUB

SUB FrameRect(rect()) STATIC
  LINE (rect(1),rect(0))-(rect(3),rect(0))
  LINE (rect(3),rect(0))-(rect(3),rect(2))
  LINE (rect(3),rect(2))-(rect(1),rect(2))
  LINE (rect(1),rect(2))-(rect(1),rect(0))
END SUB

IgnoreBreak:
  RETURN